




;;------------------------------------------------------------------------
;;programmers transformation object proto
;;------------------------------------------------------------------------

(defproto programmers-transf-object-proto 
  '(program-data program-variables program-vartypes program-obslabels) 
  () transf-object-proto)

(defmeth programmers-transf-object-proto :program-data (&optional (value nil set))
    (if set (setf (slot-value  'program-data) value))
    (slot-value 'program-data))

(defmeth programmers-transf-object-proto :program-variables (&optional (value nil set))
    (if set (setf (slot-value  'program-variables) value))
    (slot-value 'program-variables))

(defmeth programmers-transf-object-proto :program-vartypes (&optional (value nil set))
    (if set (setf (slot-value  'program-vartypes) value))
    (slot-value 'program-vartypes))


(defmeth programmers-transf-object-proto :program-obslabels (&optional (value nil set))
    (if set (setf (slot-value  'program-obslabels) value))
    (slot-value 'program-obslabels))

;arguments for modelobject
;data-list variables types labels freq data-type
;freq-way-names array tool-id data-obj title 
;name dialog &optional (ok-types '(numeric)))

(defmeth programmers-transf-object-proto :isnew 
        (program-variables program-data program-vartypes  &rest args)
 (send self :program-data program-data)
  (send self :program-variables program-variables)
  (send self :program-vartypes program-vartypes)
  (apply #'call-next-method args))

(defmeth programmers-transf-object-proto :options () t)

(defmeth programmers-transf-object-proto :analysis ()
  (let* ((types (send self :program-vartypes))
         (labels (send self :program-obslabels))
         (data (send self :program-data))
         )
    (if (not types) (setf types (repeat "Numeric" (length (send self :program-variables)))))
    (if (not labels) (if (= (send *current-data* :nobs)
                            (length (first data)))
                         (setf labels (send *current-data* :labels))))
    (data (send self :name)
          :created (send *workmap* :selected-icon)
          :variables (send self :program-variables)
          :types types
          :labels labels
          :freq      (send self :freq)
          :row-label (send self :row-label)
          :column-label (send self :column-label)
          :program data
          )))

(defun transform (&key variables program use types)
"Args: &KEY VARIABLES PROGRAM USE TYPES
Function for writing transformation programs. The TRANSFORM function takes variables from an existing dataobject, performs calculations on them that are specified by code appearing inside this function, creates a new transformation object (and workmap icon), and creates a new data object (and workmap icon) containing the results of the calculations. The arguments are used as follows:
  :USE specifies which ViSta dataobject is to be made the current dataobject, and causes a local environment to be created which contains bindings of every variable in the dataobject. These variables are the input to the transformation program that follows. The data object name may be a symbol or string. If a symbol it must be preceeded by a single quote.
  :PROGRAM is followed by Lisp Code which defines the transformation. This may be any Lisp code. It may use some or all (or none) of the variables in the USE dataobject. All of the variables in the dataobject have bindings in the local enviroment. The code must return a list of lists. The number of lists must equal the number of variables defined by the :VARIABLES keyword. Each list must have the same number of elements. The lists may be represented by symbols bound to lists.
  :VARIABLES is followed by a single-quoted list of variable names. There must be one variable name for each list returned by the :PROGRAM code. These variables are the output of the transformation. They are placed into the new dataobject that is the result of the transformation.
  :TYPES is followed by a list of variable types (Category, Ordinal, Numeric)."

  (setcd use)
  (send programmers-transf-object-proto :new 
        variables program types
        "UsrTrn" use "User Defined Transformation" "UsrTrn" nil))




;========================================================



(defun split-by-categories  (&key 
                           (data     current-data)
                           (dialog     nil)
                           (name       "Split")
                           (title      nil)
                           )
"Splits data files by a category variable to create several new dataobjects, one for each category."
   (send split-transf-object-proto :new 9 data title name dialog '(all)))


(defproto split-transf-object-proto '() () transf-object-proto)

(defmeth split-transf-object-proto :isnew (&rest args)
  (apply #'call-next-method args)
  )

(defmeth split-transf-object-proto :options () t)

(defmeth split-transf-object-proto :analysis ()
  (let* (
         (cat-data-matrix (send current-data :active-data-matrix '(category)))
         (variables (send current-data :active-variables '(category)))
         (num-variables (array-dimension cat-data-matrix 1))
         (cases-in-var)
         (cats)
         (data-matrix-out)
         (variables-out)
         (types-out)
         (labels (send current-data :active-labels))
         (creator (- (send *desktop* :num-icons) 1))
         )    
    (when (> num-variables 1) (error-message "Select exactly one categorical variable"))
    (when (= num-variables 0) (error-message "Select exactly one categorical variable"))
    (when (= num-variables 1)
          (setf cats (coerce (remove-duplicates (first (column-list cat-data-matrix)) :test 'equal) 'list))
          (setf data-matrix-out
                (apply 'bind-columns
                       (select (column-list (send current-data :data-matrix))
                               (sort-data (set-difference (iseq (length (send current-data :variables)))
                                                          (position variables (send current-data :variables)))))))
          (setf variables-out (select (send current-data :variables)
                                      (sort-data (set-difference (iseq (length (send current-data :variables)))
                                                      (position variables (send current-data :variables))))))
          (setf types-out (select (send current-data :types)
                                      (sort-data (set-difference (iseq (length (send current-data :variables)))
                                                      (position variables (send current-data :variables))))))
          (setf cases-in-var
                (mapcar #'(lambda (cat)
                           (which (mapcar #'(lambda (val) (equal val cat))
                                   (coerce (first (column-list cat-data-matrix)) 'list))))
                        cats))

          (mapcar #'(lambda (cases cat)
                      (data cat
                            :created   creator
                            :title     cat
                            :labels    (select labels cases)
                            :data      (combine (select (row-list data-matrix-out) cases))
                            :variables variables-out
                            :types     types-out
                            ))
                  cases-in-var cats)
          
          )))

#|

Forrest,

Sometimes it is useful to concatenate two categorical variables in a new 
categorical variable that includes the values of the other two variables. 
This is useful for correspondence analysis when you need to colapse 
variables because you have more than two and you want to ignore some 
interactions.

I wrote a transformation for this. However, it only uses categorical 
variables but the menu item for this transformation is off when the dataset 
is categorical (only category variables). Any suggestion. The file attached 
has the code for the transformation.

|#


(defun join-category-variables  (&key 
   (data     current-data)
   (dialog     nil)
   (name       "Join")
   (title      nil))
"Joins Category variables to create a new variable"
;(trace :new :isnew)
   (send concatenate-transf-object-proto :new 9 data title name dialog '(all)))


(defproto concatenate-transf-object-proto '() () transf-object-proto)

(defmeth concatenate-transf-object-proto :isnew (&rest args)
  (apply #'call-next-method args)
  )

(defmeth concatenate-transf-object-proto :options () t)

(defmeth concatenate-transf-object-proto :analysis ()
  (let* (
         (data-matrix (send current-data :active-data-matrix '(category)))
         (variables (send current-data :active-variables '(category)))
         (num-variables (array-dimension data-matrix 1))
         (concatenate-data-matrix (if (> num-variables 0)
                                      (concatenate-columns (column-list data-matrix))
                                      (error-message "No categorical variables in the dataset")))
         (concatenate-variable-name (concatenate-columns variables))

         )
(when (> num-variables 0)
    (data (send self :name)
          :created   (- (send *desktop* :num-icons) 1)
          :title     (concatenate 'string "Conct-" (send self :title))
          :labels    (send current-data :active-labels) 
          :data      (combine concatenate-data-matrix)
          :variables (combine concatenate-variable-name)
          :types     '(Category)
          ))
 )
    )


(defun concatenate-columns (list-of-elements &optional (separator "-"))
  "Generates columns of separators the same length as the list-of-elements as first step for concatening"
  (let* ((data list-of-elements)
        (num-col (length data))
        (separator separator)
        (add-separator (mapcar #'(lambda (i)
                                   (map-elements 'strcat 
                                                 (select data i) 
                                                 separator))
                              (iseq (- num-col 1))))
         (add-separator (append add-separator (last data)))
         (output (apply 'map-elements 'strcat add-separator))
        )
    output))